perm filename CAL.SAI[SAI,LES]1 blob
sn#815189 filedate 1986-04-21 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00004 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 begin "CAL"
C00007 00003 scnbrk(flush,<" ,-'/ ">,null,"xnr")
C00012 00004 ! start here
C00016 ENDMK
C⊗;
begin "CAL"
require "head[1,les]" source_file;
define fontheight=[26]; ! height of printing font in pixels;
PRELOAD_WITH "January", "February", "March", "April", "May", "June",
"July", "August", "September", "October", "November", "December";
STRING ARRAY MONTH[1:12];
preload_with "Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday";
string array weekday[0:6];
preload_with 31,29,31,30,31,30,31,31,30,31,30,31; ! max. days/month;
integer array daymo[1:12];
preload_with 0,31,59,90,120,151,181,212,243,273,304,334;
integer array cumday[1:12]; ! total days in prior months;
boolean proc equiv(STRING A,B); begin
! returns true if A is identical to B[1 to length(A)], neglecting case shifts;
WHILE LN(A) DO IF (LOP(A) LAND '137)≠(LOP(B) land '137) THEN RETURN(FALSE);
RETURN(TRUE)
END;
integer proc match(string m; string array ss; integer sstop); begin
integer mi,mp,ml; ! find unambiguous match between;
mp←0; if (ml←ln(m))=0 then return(0); ! m and one of ss;
for mi←1 thru sstop do if equiv(m,ss[mi]) then
if mp then return(-1) else mp←mi;
return(mp)
end "MATCH";
! DATE FORMAT: byte(27) year,(4) month, (5) day;
define yr(dat)=[(dat lsh -9)],mo(dat)=[((dat lsh -5)land '17)],
da(dat)=[(dat land '37)],ymd(y,m,d)=[(((((y) lsh 4)lor (m))lsh 5)lor (d))];
string proc dates(integer date); return(cvs(da(date))&" "&month[mo(date)]&" "&
cvs(yr(date)));
boolean proc leap(integer year); ! true if leap year;
return(((year←yr(year))mod 4)=0 ∧ (year mod 100)≠0 ∨ (year mod 400)=0);
integer proc yearday(integer year); ! year code (0=Monday);
return(((year←yr(year)-1)+year%4-year%100+year%400-1)mod 7);
integer proc leapday(integer date); ! 1 if leap ∧ ≥Feb.29 else 0;
return(if (date land '777)>ymd(0,2,28) ∧ leap(date) then 1 else 0);
integer proc daysinmo(integer date); ! # of days in month;
return(if (date land '740)≠ymd(0,2,0) ∨ leap(date) then daymo[mo(date)]
else 28);
integer proc dayis(integer date); ! day of week: 0=Monday;
return((yearday(date) + cumday[mo(date)]+leapday(date)+da(date))mod 7);
integer proc sysdate(integer sdate); ! convert system date to above;
return(ymd(<sdate%(12*31)+1964>,<(sdate%31)mod 12 +1>,<sdate mod 31 +1>));
integer proc upmo(integer date); ! increment month;
return(if (date land '740)<ymd(0,12,0) then date land(lnot '37)+ymd(0,1,1)
else date land (lnot '777)+ymd(1,1,1));
integer proc update(integer date); ! increment date;
return(if da(date)<daysinmo(date) then date+1 else upmo(date));
scnbrk(flush,<" ,-'/ ">,null,"xnr");
scnbrk(scalet,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz",null,"xnr");
define outfile=["cal.xxx[spl,sys]"];
! XGP commands;
define fontsel(fnt)=[(del&1&fnt)],
startund=[(del&1&'46)],stopund(line)=[(del&1&'47)&(line)],
skipi(lines)=[(cr&del&1&'42)&(lines)];
string proc skip(integer lines); begin ! vertical skip;
string com,cms; integer n;
n←(lines←lines-fontheight)%'177;
cms←com←skipi(lines%n);
for n←n-1 step -1 until 1 do cms←cms&com;
return(cms);
end "SKIP";
string proc colsel(integer col); ! xgp column select;
return((del&1&" ")&(col%128)&(col mod 128));
proc poot(string ss); out(ouch,ss);
proc xspool(string file; integer mar(-1),pmar(-1),lmar(-1)); begin
string mars;
release(ouch); mars←cvs(mar);
ptostr(0,"XSP "&FILE&(if mar≥0 then "/TM="&mars&"/BM="&mars else "")&
(if pmar≥0 then "/PM="&cvs(pmar) else null)&
(if lmar≥0 then "/LM="&cvs(lmar) else null)&
"/RM=1800/NOH/NOT/DEL"&↓);
call(0,"exit");
end "XSPOOL";
procedure diary(integer date,rep,height,mar); begin ! XGP a diary;
integer day,ri,rj,pmar;
string ls;
day←dayis(date); ! find day of week;
ls←skip((pmar←height-2*mar)%7);
ent(outfile);
for rep←rep step -1 until 1 do begin "page"
procedure outday; begin ! print a day;
poot(weekday[day]&colsel(280)&dates(date));
date←update(date); day←(day+1)mod 7;
end;
for ri←1 thru 6 do begin outday; poot(ls); end;
outday; poot(↓&ff)
end "page";
xspool(outfile&"/FONT=NGB25",mar,pmar,70);
end "DIARY";
procedure wrist(integer date,day,rep); begin
integer day1,bi,wi,lbord;
string ws;
string array dast[1:6];
define lmar=[10],
dayhead=[" M T W T F S S M T W T F S"],
datestr=[" 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15]&
[ 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31"];
string proc nexcol; ! select next column;
return(if bi<6 then colsel(lbord←lbord+283) else ↓);
ent(outfile);
day1←day+6-dayis((date land(lnot '37))+1); ! # of dates, 1st week;
ws←startund&dayhead[1+3*day for 20]&stopund(3); ! days of week;
for rep←rep step -1 until 1 do begin "six months"
poot(fontsel(0)); lbord←lmar;
for bi←1 thru 6 do begin "month year"
poot(month[mo(date)]&colsel(145+lbord)&cvs(yr(date))&
nexcol);
dast[bi]←" "[1 to 18-3*(day1 mod 7)]&
datestr[1 to 3*(wi←daysinmo(date))]&
" "[1 to 44];
day1←day1+35-wi; date←upmo(date);
end "month year";
poot(fontsel(1)); lbord←lmar;
for bi←1 thru 6 do poot(ws&nexcol); ! days of week;
for wi←0 thru 5 do begin "dates"
lbord←lmar;
for bi←1 thru 6 do poot(dast[bi][21*wi+1 for 21]&nexcol);
end "dates";
poot(ff);
end "six months";
xspool(outfile&"/FONT#0=NGR20/FONT#1=FIX13X",80,160,lmar);
end "WRIST";
! start here;
integer day,date;
integer proc indate(string data); begin ! convert date string;
integer id,im,iy,ii,ibr;
id←im←iy←0; flush(data);
while ln(data) do begin "scan date"
if "1"≤data≤"9" then
if (ii←intscan(data,ibr))<32 then
if id then return(-1) else id←ii
else iy←(if ii<100 then 1900+ii else ii)
else if (im←match(scalet(data),month,12))≤0 then return(-2);
flush(data);
end;
if iy=0 then begin "no year"
iy←yr(date);
if im=0 then if id=0 then return(-3) else im←mo(date) else begin
if im<mo(date) then iy←iy+1;
if id=0 then id←1;
end
end "no year"
else if im=0 then if id=0 then im←id←1 else return(-4)
else if id=0 then id←1;
return(ymd(iy,im,id))
end "INDATE";
day←dayis(date←sysdate(call(0,"date"))); ! set to today;
say("COMMANDS:
<date> sets to that date (e.g. ""6 feb 74"" or ""feb 1974"" or ""FEB"" or ""74"").
<blank> increments day by one.
!d<integer> makes a diary beginning on current day and running for <integer> weeks
Additional parameters, if present, are separated by commas and
represent page height, and top and bottom margins both in 5 mil
units (200/inch). Default values are 1000,25 (4.5 inches, 1/8 inch).
!w<integer> makes wrist calendars beginning with current month and running for
<integer> months, beginning each week with the current day of the week
");
while true do begin "loop"
integer li; string s;
label more;
say(weekday[day]&", "&dates(date)&↓);
more: if ln(s←ask("*")) then if s="!" then begin
integer lc;
lc←s[2 for 1]; s←s[3 to ∞];
if (li←intscan(s,brk))<0 then li←1;
if lc="W" ∨ lc="w" then wrist(date,dayis(date),li)
else begin "diary"
integer height,mar;
flush(s);
height←if ln(s) then intscan(s,brk) else 1000;
flush(s);
mar←if ln(s) then intscan(s,brk) else 25;
diary(date,li,height,mar);
end "diary";
end
else if (li←indate(s))<0 then begin say("Eh? "&↓); go to more end
else day←dayis(date←li)
else begin
date←update(date); day←(day+1)mod 7;
end;
end "loop";
end